home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / annotations.el.z / annotations.el
Encoding:
Text File  |  1998-05-21  |  16.5 KB  |  447 lines
  1. ;;; annotations.el --- interface to marginal annotations
  2.  
  3. ;; Copyright (C) 1992-1994 Free Software Foundation, Inc.
  4. ;;
  5. ;; Created: 10-Oct-93, Chuck Thompson <cthomp@cs.uiuc.edu>
  6. ;; Keywords: extensions, hypermedia, outlining
  7. ;; Enhanced by Andy Piper <ajp@eng.cam.ac.uk>: 6-may-94
  8. ;;
  9. ;; Last modified:  12-May-95 by Chuck Thompson.
  10.  
  11. ;; This file is part of XEmacs.
  12.  
  13. ;; XEmacs is free software; you can redistribute it and/or modify it
  14. ;; under the terms of the GNU General Public License as published by
  15. ;; the Free Software Foundation; either version 2, or (at your option)
  16. ;; any later version.
  17.  
  18. ;; XEmacs is distributed in the hope that it will be useful, but
  19. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21. ;; General Public License for more details.
  22.  
  23. ;; You should have received a copy of the GNU General Public License
  24. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  25. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;; Boston, MA 02111-1307, USA.
  27.  
  28. ;;; Synched up with: Not in FSF.
  29.  
  30. ;;
  31. ;; The annotations are implemented on top of extents.  The extent property
  32. ;; 'annotation of an extent being used as an annotation is vector of size 6:
  33. ;;    [<data> <action> <menu> <glyph> <down-glyph> <rightp>]
  34. ;;
  35.  
  36. ;;;###autoload
  37. (defvar make-annotation-hook nil
  38.   "*Function or functions to run immediately after creating an annotation.")
  39.  
  40. ;;;###autoload
  41. (defvar before-delete-annotation-hook nil
  42.   "*Function or functions to run immediately before deleting an annotation.")
  43.  
  44. ;;;###autoload
  45. (defvar after-delete-annotation-hook nil
  46.   "*Function or functions to run immediately after deleting an annotation.")
  47.  
  48. (defvar annotation-local-map-default
  49.   (let ((map (make-sparse-keymap)))
  50.     (set-keymap-name map 'annotation-local-map)
  51.     (define-key map 'button1 'annotation-activate-function-default)
  52.     (define-key map 'button3 'annotation-popup-menu)
  53.     map)
  54.   "Keymap used to activate annotations with only annotation data passed.")
  55.  
  56. (defvar annotation-local-map-with-event
  57.   (let ((map (make-sparse-keymap)))
  58.     (set-keymap-name map 'annotation-local-map)
  59.     (define-key map 'button1 'annotation-activate-function-with-event)
  60.     (define-key map 'button3 'annotation-popup-menu)
  61.     map)
  62.   "Keymap used to activate annotations with annotation data and event passed.")
  63.  
  64. ;;
  65. ;; When the mouse is pressed and released over an annotation glyph
  66. ;; this will run the annotation action passing a single arg, the value
  67. ;; of the annotation data field.
  68. ;;
  69. (defun annotation-activate-function-default (event)
  70.   (interactive "e")
  71.   (let ((extent (event-glyph-extent event))
  72.     (mouse-down t)
  73.     (up-glyph nil))
  74.     ;; make the glyph look pressed
  75.     (cond ((annotation-down-glyph extent)
  76.        (setq up-glyph (annotation-glyph extent))
  77.        (set-annotation-glyph extent (annotation-down-glyph extent))))
  78.     (while mouse-down
  79.       (setq event (next-event event))
  80.       (if (button-release-event-p event)
  81.       (setq mouse-down nil)))
  82.     ;; make the glyph look released
  83.     (cond ((annotation-down-glyph extent)
  84.        (set-annotation-glyph extent up-glyph)))
  85.     (if (eq extent (event-glyph-extent event))
  86.     (if (annotation-action extent)
  87.         (funcall (annotation-action extent) (annotation-data extent))))))
  88.  
  89. ;;
  90. ;; When the mouse is pressed and released over an annotation glyph
  91. ;; this will run the annotation action passing two args, the value
  92. ;; of the annotation data field and the event which triggered the
  93. ;; annotation.
  94. ;;
  95. (defun annotation-activate-function-with-event (event)
  96.   (interactive "e")
  97.   (let ((extent (event-glyph-extent event))
  98.     (mouse-down t)
  99.     (up-glyph nil))
  100.     ;; make the glyph look pressed
  101.     (cond ((annotation-down-glyph extent)
  102.        (setq up-glyph (annotation-glyph extent))
  103.        (set-annotation-glyph extent (annotation-down-glyph extent))))
  104.     (while mouse-down
  105.       (setq event (next-event event))
  106.       (if (button-release-event-p event)
  107.       (setq mouse-down nil)))
  108.     ;; make the glyph look released
  109.     (cond ((annotation-down-glyph extent)
  110.        (set-annotation-glyph extent up-glyph)))
  111.     (if (eq extent (event-glyph-extent event))
  112.     (if (annotation-action extent)
  113.         (funcall (annotation-action extent) (annotation-data extent)
  114.              event)))))
  115.  
  116. ;; #### Glyphs should be glyphs should be glyphs
  117. ;;;###autoload
  118. (defun make-annotation (glyph &optional pos layout buffer with-event d-glyph rightp)
  119.   "Create a marginal annotation, displayed using GLYPH, at position POS.
  120. GLYPH may be either a glyph object or a string.  Use layout policy
  121. LAYOUT and place the annotation in buffer BUFFER.  If POS is nil, point is
  122. used.  If LAYOUT is nil, `whitespace' is used.  If BUFFER is nil, the
  123. current buffer is used.  If WITH-EVENT is non-nil, then when an annotation
  124. is activated, the triggering event is passed as the second arg to the
  125. annotation function.  If D-GLYPH is non-nil then it is used as the glyph 
  126. that will be displayed when button1 is down.  If RIGHTP is non-nil then
  127. the glyph will be displayed on the right side of the buffer instead of the
  128. left."
  129.   (let ((new-annotation))
  130.     ;; get the buffer to add the annotation at
  131.     (if (not buffer)
  132.     (setq buffer (current-buffer))
  133.       (setq buffer (get-buffer buffer)))
  134.     ;; get the position to put it at
  135.     (if (not pos)
  136.     (save-excursion
  137.       (set-buffer buffer)
  138.       (setq pos (point))))
  139.     ;; make sure it gets some layout policy
  140.     (if (not layout)
  141.     (setq layout 'whitespace))
  142.  
  143.     ;; make sure the glyph arguments are actually glyphs
  144.     (if (and glyph (not (glyphp glyph)))
  145.     (setq glyph (make-glyph glyph)))
  146.     (if (and d-glyph (not (glyphp d-glyph)))
  147.     (setq d-glyph (make-glyph d-glyph)))
  148.  
  149.     ;; create the actual annotation
  150.     (setq new-annotation (make-extent pos pos buffer))
  151.     (detach-extent new-annotation)
  152.     (set-extent-endpoints new-annotation pos pos)
  153.     (if rightp
  154.     (set-extent-end-glyph new-annotation glyph layout)
  155.       (set-extent-begin-glyph new-annotation glyph layout))
  156.     (set-extent-property new-annotation 'annotation 
  157.              (vector nil nil nil glyph d-glyph rightp))
  158.     (set-extent-property new-annotation 'end-closed t)
  159.     (set-extent-property new-annotation 'start-open t)
  160.     (set-extent-property new-annotation 'duplicable t)
  161.     (if with-event
  162.     (set-extent-property new-annotation 'keymap
  163.                  annotation-local-map-with-event)
  164.       (set-extent-property new-annotation 'keymap
  165.                annotation-local-map-default))
  166.     (run-hook-with-args 'make-annotation-hook new-annotation)
  167.     new-annotation))
  168.  
  169. (fset 'make-graphic-annotation 'make-annotation)
  170. (make-obsolete 'make-graphic-annotation 'make-annotation)
  171.  
  172. ;;;###autoload
  173. (defun delete-annotation (annotation)
  174.   "Remove ANNOTATION from its buffer.  This does not modify the buffer text."
  175.   (if (not (annotationp annotation))
  176.       (error "%s is not an annotation" annotation)
  177.     (progn
  178.       (run-hook-with-args 'before-delete-annotation-hook annotation)
  179.       (delete-extent annotation)
  180.       (run-hooks 'after-delete-annotation-hook))))
  181.  
  182. ;;;###autoload
  183. (defun annotationp (annotation)
  184.   "T if OBJECT is an annotation."
  185.   (and (extent-live-p annotation)
  186.        (not (null (extent-property annotation 'annotation)))))
  187.  
  188. (defun annotation-visible (annotation)
  189.   "T if there is enough available space to display ANNOTATION."
  190.   (if (not (annotationp annotation))
  191.       (error "%s is not an annotation" annotation)
  192.     (not (extent-property annotation 'glyph-invisible))))
  193.  
  194. ;;;###autoload
  195. (defun annotation-at (&optional pos buffer)
  196.   "Return the first annotation at POS in BUFFER.
  197. BUFFER defaults to the current buffer.  POS defaults to point in BUFFER."
  198.   (car (annotations-at pos buffer)))
  199. (make-obsolete 'annotation-at 'annotations-at)
  200.  
  201. (defun annotation-layout (annotation)
  202.   "Return the layout policy of annotation ANNOTATION.  The layout policy
  203. is set using `set-annotation-layout'."
  204.   (if (not (annotationp annotation))
  205.       (error "%s is not an annotation" annotation)
  206.     (if (eq 'right (annotation-side annotation))
  207.     (extent-end-glyph-layout annotation)
  208.       (extent-begin-glyph-layout annotation))))
  209.  
  210.  
  211. (defun annotation-side (annotation)
  212.   "Return the side of the buffer the annotation is displayed on.
  213. Return value is either 'left or 'right."
  214.   (if (aref (extent-property annotation 'annotation) 5)
  215.       'right
  216.     'left))
  217.  
  218. (defun set-annotation-layout (annotation layout)
  219.   "Set the layout policy of ANNOTATION to LAYOUT.  The function
  220. `annotation-layout' returns the current layout policy."
  221.   (if (not (annotationp annotation))
  222.       (error "%s is not an annotation" annotation)
  223.     (if (eq 'right (annotation-side annotation))
  224.     (set-extent-end-glyph-layout annotation layout)
  225.       (set-extent-begin-glyph-layout annotation layout))))
  226.  
  227. ;; Now that annotatios use glyphs this function has little value and
  228. ;; will actually not work as is.
  229. ;(defun annotation-type (annotation)
  230. ;  "Return the display type of the annotation ANNOTATION.  The type will
  231. ;be one of the following symbols:
  232. ;
  233. ;    pixmap
  234. ;    bitmap
  235. ;    string
  236. ;    nil    (the object is not an annotation)"
  237. ;  (if (not (annotationp annotation))
  238. ;      nil
  239. ;    (let ((glyph (annotation-glyph annotation)))
  240. ;      (if (stringp glyph)
  241. ;      'stringp
  242. ;    (if (not (pixmapp glyph))
  243. ;        (error "%s is a corrupt annotation" annotation)
  244. ;      (if (> (pixmap-depth glyph) 0)
  245. ;          'pixmap
  246. ;        'bitmap))))))
  247. (make-obsolete 'annotation-type "This function no longer has any meaning.")
  248.  
  249. (defun annotation-width (annotation)
  250.   "Return the width of the annotation ANNOTATION in pixels."  
  251.   (if (not (annotationp annotation))
  252.       (error "%s is not an annotation" annotation)
  253.     (glyph-width (annotation-glyph annotation))))
  254.  
  255. (defun annotation-glyph (annotation)
  256.   "If ANNOTATION is of type `string' return the string.  Otherwise, return
  257. the glyph object used to display ANNOTATION.  The glyph is set using
  258. `set-annotation-glyph'."
  259.   (if (not (annotationp annotation))
  260.       (error "%s is not an annotation" annotation)
  261.     (aref (extent-property annotation 'annotation) 3)))
  262.  
  263. (defun set-annotation-glyph (annotation glyph &optional layout side)
  264.   "Set the representation of ANNOTATION to GLYPH.
  265. GLYPH should be a glyph object.  If LAYOUT is non-nil, set the layout
  266. policy of the annotation to LAYOUT.  If SIDE is equal to 'left or 'right
  267. change the side of the annotation to that value.
  268. The function `annotation-glyph' returns the current glyph."
  269.   (if (not (annotationp annotation))
  270.       (error "%s is not an annotation" annotation)
  271.     (progn
  272.       (if (not layout)
  273.       (setq layout (extent-layout annotation)))
  274.       (if (or (eq side 'right)
  275.           (and (not (eq side 'left))
  276.            (eq (annotation-side annotation) 'right)))
  277.       (set-extent-end-glyph annotation glyph layout)
  278.     (set-extent-begin-glyph annotation glyph layout))
  279.       (aset (extent-property annotation 'annotation) 3 glyph)
  280.       (if (eq side 'right)
  281.       (aset (extent-property annotation 'annotation) 5 t))
  282.       (if (eq side 'left)
  283.       (aset (extent-property annotation 'annotation) 5 nil))
  284.       (annotation-glyph annotation))))
  285.  
  286. (defun annotation-down-glyph (annotation)
  287.   "If ANNOTATION is of type `string' return the down string.  Otherwise,
  288. return the glyph object of the down-glyph representing ANNOTATION.
  289. The down-glyph is set using `set-annotation-down-glyph'."
  290.   (if (not (annotationp annotation))
  291.       (error "%s is not an annotation" annotation)
  292.     (aref (extent-property annotation 'annotation) 4)))
  293.  
  294. (defun set-annotation-down-glyph (annotation glyph)
  295.   "Set the depressed representation of ANNOTATION to GLYPH.  
  296. GLYPH should be a glyph object. 
  297. The function `annotation-down-glyph' returns the current down-glyph."
  298.   (if (not (annotationp annotation))
  299.       (error "%s is not an annotation" annotation)
  300.     (aset (extent-property annotation 'annotation) 4 glyph)))
  301.  
  302. (define-obsolete-function-alias 'annotation-graphic 'annotation-glyph)
  303. (define-obsolete-function-alias 'set-annotation-graphic 'set-annotation-glyph)
  304.   
  305. (defun annotation-data (annotation)
  306.   "Return the data associated with annotation ANNOTATION.  The data is
  307. set using `set-annotation-data'."
  308.   (if (not (annotationp annotation))
  309.       (error "%s is not an annotation" annotation)
  310.     (aref (extent-property annotation 'annotation) 0)))
  311.  
  312. (defun set-annotation-data (annotation data)
  313.   "Set the data field of ANNOTATION to DATA.
  314. The function `annotation-data' returns the current data."
  315.   (if (not (annotationp annotation))
  316.       (error "%s is not an annotation" annotation)
  317.     (aset (extent-property annotation 'annotation) 0 data)))
  318.  
  319. (defun annotation-action (annotation)
  320.   "Return the action associated with annotation ANNOTATION.  The action
  321. is set using `set-annotation-action'."
  322.   (if (not (annotationp annotation))
  323.       (error "%s is not an annotation" annotation)
  324.     (aref (extent-property annotation 'annotation) 1)))
  325.  
  326. (defun set-annotation-action (annotation action)
  327.   "Set the action field of ANNOTATION to ACTION.
  328. The function `annotation-action' returns the current action."
  329.   (if (not (annotationp annotation))
  330.       (error "%s is not an annotation" annotation)
  331.     (aset (extent-property annotation 'annotation) 1 action)))
  332.  
  333. (defun annotation-face (annotation)
  334.   "Return the face associated with annotation ANNOTATION.
  335. The face is set using `set-annotation-face'."
  336.   (if (not (annotationp annotation))
  337.       (error "%s is not an annotation" annotation)
  338.     (extent-face annotation)))
  339.  
  340. (defun set-annotation-face (annotation face)
  341.   "Set the face associated with annotation ANNOTATION to FACE.
  342. The function `annotation-face' returns the current face."
  343.   (if (not (annotationp annotation))
  344.       (error "%s is not an annotation" annotation)
  345.     (set-extent-face annotation face)))
  346.  
  347. (defun hide-annotation (annotation)
  348.   "Remove ANNOTATION's glyph so that it is invisible."
  349.   (if (eq (annotation-side annotation) 'left)
  350.       (set-extent-begin-glyph annotation nil)
  351.     (set-extent-end-glyph annotation nil)))
  352. (define-obsolete-function-alias 'annotation-hide 'hide-annotation)
  353.  
  354. (defun reveal-annotation (annotation)
  355.   "Add ANNOTATION's glyph so that it is visible."
  356.   (if (eq (annotation-side annotation) 'left)
  357.       (set-extent-begin-glyph annotation (annotation-glyph annotation))
  358.     (set-extent-end-glyph annotation (annotation-glyph annotation))))
  359. (define-obsolete-function-alias 'annotation-reveal 'reveal-annotation)
  360.  
  361. ;;;###autoload
  362. (defun annotations-in-region (start end buffer)
  363.   "Return all annotations in BUFFER between START and END inclusively."
  364.   (save-excursion
  365.     (set-buffer buffer)
  366.  
  367.     (if (< start (point-min))
  368.       (error "<start> not in range of buffer"))
  369.     (if (> end (point-max))
  370.       (error "<end> not in range of buffer"))
  371.  
  372.     (let (note-list)
  373.       (map-extents
  374.        (function (lambda (extent dummy)
  375.            (progn
  376.              (if (annotationp extent)
  377.              (setq note-list (cons extent note-list)))
  378.              nil)))
  379.        buffer start end nil t)
  380.       note-list)))
  381.  
  382. ;;;###autoload
  383. (defun annotations-at (&optional pos buffer)
  384.   "Return a list of all annotations at POS in BUFFER.
  385. If BUFFER is nil, the current buffer is used.  If POS is nil, point is used."
  386.   (if (not buffer)
  387.       (setq buffer (current-buffer)))
  388.   (if (not pos)
  389.       (save-excursion
  390.     (set-buffer buffer)
  391.     (setq pos (point))))
  392.  
  393.   (annotations-in-region pos pos buffer)
  394. )
  395.  
  396. ;;;###autoload
  397. (defun annotation-list (&optional buffer)
  398.   "Return a list of all annotations in BUFFER.
  399. If BUFFER is nil, the current buffer is used."
  400.   (if (not buffer)
  401.     (setq buffer (current-buffer)))
  402.  
  403.   (save-excursion
  404.     (set-buffer buffer)
  405.     (annotations-in-region (point-min) (point-max) buffer)))
  406.  
  407. ;;;###autoload
  408. (defun all-annotations ()
  409.   "Return a list of all annotations in existence."
  410.   (let ((b (buffer-list))
  411.     result)
  412.     (while b
  413.       (setq result (nconc result (annotation-list (car b))))
  414.       (setq b (cdr b)))
  415.     result))
  416.  
  417. ;;; #### really this menus junk should append to the prevailing menu
  418. ;;;      in the same way `popup-mode-menu' does.  --jwz
  419.  
  420. ;; annotations menu stuff
  421. (defun annotation-popup-menu (event)
  422.   "Pop up a menu of annotations commands.
  423. Point is temporarily moved to the click position."
  424.   (interactive "e")
  425.   (let ((extent (event-glyph-extent event)))
  426.     (save-excursion
  427.       (goto-char (extent-end-position extent))
  428.       (if (annotation-menu extent)
  429.       (popup-menu (annotation-menu extent))
  430.     (popup-mode-menu)))))
  431.  
  432. (defun set-annotation-menu (annotation menu)
  433.   "Set the menu field of ANNOTATION to MENU.  The function
  434. `annotation-menu' returns the current menu."
  435.   (if (not (annotationp annotation))
  436.       (error "%s is not an annotation" annotation)
  437.     (aset (extent-property annotation 'annotation) 2 menu)))
  438.  
  439. (defun annotation-menu (annotation)
  440.   "Return the menu associated with annotation ANNOTATION.  The menu
  441. is set using `set-annotation-menu'."
  442.   (if (not (annotationp annotation))
  443.       (error "%s is not an annotation" annotation)
  444.     (aref (extent-property annotation 'annotation) 2)))
  445.  
  446. (provide 'annotations)
  447.